home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / OWLDEMOS.PAK / COMMDLGS.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  9KB  |  330 lines
  1. {***************************************************}
  2. {                                                   }
  3. {   Turbo Pascal for Windows                        }
  4. {   Windows 3.1 Common Dialogs Demo Program         }
  5. {                                                   }
  6. {   Copyright (c) 1992 by Borland International     }
  7. {                                                   }
  8. {***************************************************}
  9.  
  10.  
  11. program CommDlgs;
  12.  
  13. { This program demonstrates the use of several new Windows 3.1
  14.   features: The Common Dialogs (for Font and Color selection),
  15.   True Type, and Playing sounds.
  16. }
  17.  
  18. uses WinCrt, WinDos, Strings, WinTypes, WinProcs, WObjects, CommDlg,
  19.   MMSystem, BWCC;
  20.  
  21. {$R CommDlgs}
  22.  
  23. const
  24.  
  25. { Resource IDs }
  26.  
  27.   id_Menu    = 100;
  28.   id_About   = 100;
  29.   id_Icon    = 100;
  30.  
  31. { Menu command IDs }
  32.  
  33.   cm_FileOpen = 101;
  34.   cm_Color    = 103;
  35.   cm_Font     = 104;
  36.   cm_Help     = 105;
  37.   cm_HelpAbout= 106;
  38.  
  39. { Other Constants }
  40.  
  41.   HelpName    = 'CommDlgs.hlp';
  42.   FlagWidth   = 251;
  43.   FlagHeight  = 180;
  44.  
  45. type
  46.  
  47. { Filename string }
  48.  
  49.   TFilename = array [0..255] of Char;
  50.  
  51. { Application main window }
  52.  
  53.   PCommDlgsWindow = ^TCommDlgsWindow;
  54.   TCommDlgsWindow = Object(TWindow)
  55.     FlagMap  : HBitMap;
  56.     TheFont  : HFont;
  57.     ALogFont : TLogFont;
  58.     ColorRef : LongInt;
  59.     FileName : TFileName;
  60.  
  61.     constructor Init(AParent: PWindowsObject; AName: PChar);
  62.     destructor  Done; virtual;
  63.  
  64.     procedure MakeDefaultFont(var AFont: HFont);
  65.     procedure SetupWindow; virtual;
  66.  
  67.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  68.  
  69.     procedure CMColor(var Msg: TMessage);
  70.       virtual cm_First + cm_Color;
  71.     procedure CMFileOpen(var Msg: TMessage);
  72.       virtual cm_First + cm_FileOpen;
  73.     procedure CMFonts(var Msg: TMessage);
  74.       virtual cm_First + cm_Font;
  75.     procedure CMHelp(var Msg: TMessage);
  76.       virtual cm_First + cm_Help;
  77.     procedure CMHelpAbout(var Msg: TMessage);
  78.       virtual cm_First + cm_HelpAbout;
  79.   end;
  80.  
  81. { Application object }
  82.  
  83.   PCommDlgApp = ^TCommDlgApp;
  84.   TCommDlgApp = Object(TApplication)
  85.     procedure InitMainWindow; virtual;
  86.   end;
  87.  
  88. { Initialized globals }
  89.  
  90. const
  91.   DemoTitle: PChar = 'Common Dialogs Demo';
  92.  
  93. { Global variables }
  94.  
  95. var
  96.   App: TCommDlgApp;
  97.  
  98.  
  99. { TCommDlgsWindow Methods }
  100.  
  101. { Constructs an instance of TCommDlgsWindow.  Loads the menu and
  102.   initialize the wave file's "FileName" and the text's initial RGB
  103.   color value.
  104. }
  105. constructor TCommDlgsWindow.Init(AParent: PWindowsObject; AName: PChar);
  106. begin
  107.   TWindow.Init(AParent, AName);
  108.   Attr.Menu:= LoadMenu(HInstance, PChar(id_Menu));
  109.  
  110.   StrCopy(FileName, '');
  111.   ColorRef := RGB(0, 0, 255);
  112.   FlagMap  := 0;
  113.   TheFont  := 0;
  114. end;
  115.  
  116. { Destroys an instance of the TCommDlgsWindow by disposing of its
  117.   "FlagMap" image and Font.  Then calls on ancestral destructor to
  118.   complete the shutdown.
  119. }
  120. destructor TCommDlgsWindow.Done;
  121. begin
  122.   if FlagMap <> 0 then
  123.     DeleteObject(FlagMap);
  124.   if TheFont <> 0 then
  125.     DeleteObject(TheFont);
  126.   TWindow.Done;
  127. end;
  128.  
  129. { Sets up an Italic, Times New Roman, font handle used as the default
  130.   Font by TCommDlgsWindow in its Paint method.
  131. }
  132. procedure TCommDlgsWindow.MakeDefaultFont(var AFont: HFont);
  133. begin
  134.   FillChar(ALogFont, SizeOf(TLogFont), #0);
  135.   with ALogFont do
  136.   begin
  137.     lfHeight        := 96;     {Make a large font                 }
  138.     lfWeight        := 700;    {Indicate a Bold attribute         }
  139.     lfItalic        := 1;      {Non-zero value indicates italic   }
  140.     lfUnderline     := 1;      {Non-zero value indicates underline}
  141.     lfOutPrecision  := Out_Stroke_Precis;
  142.     lfClipPrecision := Clip_Stroke_Precis;
  143.     lfQuality       := Default_Quality;
  144.     lfPitchAndFamily:= Variable_Pitch;
  145.     StrCopy(lfFaceName, 'Times New Roman');
  146.   end;
  147.   TheFont := CreateFontIndirect(ALogFont);
  148. end;
  149.  
  150. { Establishes the font and the "FlagMap" bitmap image used in
  151.   TCommDlgsWindow's Paint method.  The FlagMap is held as an instance
  152.   variable until the window is closed.
  153. }
  154. procedure TCommDlgsWindow.SetUpWindow;
  155. begin
  156.   TWindow.SetupWindow;
  157.   MakeDefaultFont(TheFont);
  158.   FlagMap := LoadBitmap(HInstance, 'bitmap_2');
  159. end;
  160.  
  161. { Displays the bitmap held in "FlagMap".  Then surrounds this flag map
  162.   with the string 'TP Win 3.1' in the selected font and text color.
  163. }
  164. procedure TCommDlgsWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  165. var
  166.   S        : array [0..100] of Char;
  167.   aDC      : HDC;
  168.   OldBitMap: HBitMap;
  169.   Dims     : LongInt;
  170. begin
  171.   aDC := CreateCompatibleDC(PaintDC);
  172.   OldBitMap := SelectObject(aDC, FlagMap);
  173.  
  174.   StrCopy(S, 'TP ');
  175.   SelectObject(PaintDC, TheFont);
  176.   SetTextColor(PaintDC, ColorRef);
  177.   TextOut(PaintDC, 0, 0, S, StrLen(S));
  178.  
  179.   Dims := GetTextExtent(PaintDC, S, StrLen(S));
  180.   StretchBlt(PaintDC, LoWord(Dims), 0, LoWord(Dims), HiWord(Dims),
  181.              aDC, 0, 0, FlagWidth, FlagHeight, SrcCopy);
  182.   StrCopy(S, ' Win 3.1');
  183.   TextOut(PaintDC, (LoWord(Dims) * 2), 0, S, StrLen(S));
  184.  
  185.   SelectObject(aDC, OldBitMap);
  186.   DeleteDC(aDC);
  187. end;
  188.  
  189. { Displays the "Open File Dialog" from Common dialogs and permit the user
  190.   to select from among the available Wave files.  Then play the sound
  191.   found in the file using "SndPlaySound".
  192. }
  193. procedure TCommDlgsWindow.CMFileOpen(var Msg: TMessage);
  194. const
  195.   DefExt = 'wav';
  196. var
  197.   OpenFN      : TOpenFileName;
  198.   Filter      : array [0..100] of Char;
  199.   FullFileName: TFilename;
  200.   WinDir      : array [0..145] of Char;
  201. begin
  202.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  203.   SetCurDir(WinDir);
  204.   StrCopy(FullFileName, '');
  205.  
  206. { Set up a filter buffer to look for Wave files only.  Recall that filter
  207.   buffer is a set of string pairs, with the last one terminated by a
  208.   double-null.
  209. }
  210.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  211.   StrCopy(Filter, 'Wave Files');
  212.   StrCopy(@Filter[StrLen(Filter)+1], '*.wav');
  213.  
  214.   FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  215.   with OpenFN do
  216.   begin
  217.     hInstance     := HInstance;
  218.     hwndOwner     := HWindow;
  219.     lpstrDefExt   := DefExt;
  220.     lpstrFile     := FullFileName;
  221.     lpstrFilter   := Filter;
  222.     lpstrFileTitle:= FileName;
  223.     flags         := ofn_FileMustExist;
  224.     lStructSize   := sizeof(TOpenFileName);
  225.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  226.     nMaxFile      := SizeOf(FullFileName);
  227.   end;
  228.   if GetOpenFileName(OpenFN) then
  229.     SndPlaySound(FileName, 1);   {Second parameter must be 1}
  230. end;
  231.  
  232. { Displays the "Choose Color" dialog from the common dialogs unit.
  233.   Permits an initial value to be inserted and custom colors to be
  234.   developed. Note, custom colors are not used by the "ChooseFont"
  235.   dialog from common dialogs.
  236. }
  237. procedure TCommDlgsWindow.CMColor(var Msg: TMessage);
  238. type
  239.   TLongAry = array [0..15] of Longint;
  240. const
  241.   { Establishes a set of custom colors in 15 shades of blue }
  242.   CustColors: TLongAry = (
  243.     $000000, $100000, $200000, $300000,
  244.     $400000, $500000, $600000, $700000,
  245.     $800000, $900000, $A00000, $B00000,
  246.     $C00000, $D00000, $E00000, $F00000);
  247. var
  248.   ChooseClr: TChooseColor;
  249.   i        : Integer;
  250. begin
  251.   with ChooseClr do
  252.   begin
  253.     HWndOwner   := HWindow;
  254.     lStructSize := Sizeof(TChooseColor);
  255.     rgbResult   := ColorRef;
  256.     lpCustColors:= @CustColors;
  257.     Flags       := cc_FullOpen or cc_RGBInit;
  258.       {Allow custom colors and the initialization through rgbResult}
  259.   end;
  260.   if not ChooseColor(ChooseClr) then
  261.     Exit;
  262.   ColorRef := ChooseClr.RGBResult;
  263.   InvalidateRect(HWindow, nil, True);
  264. end;
  265.  
  266. { Displays the ChooseFont dialog to permit the selection of a font which
  267.   is returned as a TLogFont.  Then a font handle is created from this
  268.   logical font information.
  269. }
  270. procedure TCommDlgsWindow.CMFonts(var Msg: TMessage);
  271. var
  272.   ChooseRec: TChooseFont;
  273.   Colors   : LongInt;
  274.   Style    : array [0..100] of Char;
  275.   TempFont : TLogFont;
  276. begin
  277.   FillChar(ChooseRec, SizeOf(ChooseRec), #0);
  278.   with ChooseRec do
  279.   begin
  280.     lStructSize:= SizeOf(TChooseFont);
  281.     hwndOwner  := HWindow;
  282.     lpLogFont  := @ALogFont;
  283.     Flags      := cf_ScreenFonts or cf_Effects or cf_InitToLogFontStruct;
  284.     rgbColors  := ColorRef;
  285.     lpszStyle  := Style;
  286.   end;
  287.   if not ChooseFont(ChooseRec) then
  288.     Exit;
  289.  
  290. { Update the Font and Color data fields, then cause the window to be
  291.   repainted.
  292. }
  293.   if TheFont <> 0 then
  294.     DeleteObject(TheFont);
  295.   ColorRef:= ChooseRec.rgbColors;
  296.   TheFont := CreateFontIndirect(ALogFont);
  297.   InvalidateRect(HWindow, nil, True);
  298. end;
  299.  
  300. { Displays the help index for the Demo Help File.
  301. }
  302. procedure TCommDlgsWindow.CMHelp(var Msg: TMessage);
  303. begin
  304.   WinHelp(HWindow, HelpName, Help_Index, 0);
  305. end;
  306.  
  307. { Displays the program's About Box dialog.
  308. }
  309. procedure TCommDlgsWindow.CMHelpAbout(var Msg: TMessage);
  310. begin
  311.   Application^.ExecDialog(New(PDialog, Init(@Self, PChar(id_About))));
  312. end;
  313.  
  314.  
  315. { TCommDlgApp Methods }
  316.  
  317. procedure TCommDlgApp.InitMainWindow;
  318. begin
  319.   MainWindow := New(PCommDlgsWindow, Init(nil, Application^.Name));
  320. end;
  321.  
  322.  
  323. { Main program }
  324.  
  325. begin
  326.   App.Init(DemoTitle);
  327.   App.Run;
  328.   App.Done;
  329. end.
  330.